home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac Magazin/MacEasy 25
/
Mac Magazin and MacEasy Magazine CD - Issue 25.iso
/
Grafik & Text
/
Alpha
/
Tcl
/
SystemCode
/
procs.tcl
< prev
next >
Wrap
Text File
|
1996-08-15
|
31KB
|
1,235 lines
#==============================================================================
# Load electric alias, rebind tcl file completion for precedence.
proc loadElectricAlias {} {
global HOME
uplevel #0 {
source "$HOME:Tcl:ElectricAlias:electricAlias.tcl"
}
message "ElectricAlias loaded."
bind '\t' tclFileCompletion "Shel"
enableMenuItem -m install "Electric Alias" off
}
proc debug {} {
uplevel #0 {
set debugging 1
}
}
proc normalLeftBracket {} {
insertText "\{"
}
proc normalRightBracket {} {
insertText "\}"
}
bind '\[' <zs> normalLeftBracket
bind '\]' <zs> normalRightBracket
# Select the next or current word. If word already selected, will go to next.
proc hiliteWord {} {
if {[getPos]!=[selEnd]} forwardChar
forwardWord
set start [getPos]
backwardWord
select $start [getPos]
}
bind 'h' <z> hiliteWord
#================================================================================
# Mode variables
#================================================================================
# For mark stack.
set markName 0
set markStack ""
# mapping of windows to current modes.
set winModes("") ""
# making vars local to windows
# 'incomingVars' used to hold old var values that have been overwritten in current window
#================================================================================
# Handle 'flag' and 'var' menu selections.
#================================================================================
# proc editFlag {menu item} {
# global $item incomingVars localVars modifiedVars tcl_var_procs
#
# if {[regexp {\? (.*)} $item dummy var]} {
# alphaHelp
# eval select [search -f 1 -r 1 "^$var"]
# return
# }
# lappend modifiedVars $item
# set val [expr ([set $item]-1)*-1]
# markMenuItem $menu $item [expr ($val)?"on":"off"]
# set $item $val
#
# if {[info exists tcl_var_procs($item)]} {
# $tcl_var_procs($item) $item
# }
# }
proc editVar {menu item} {
global $item incomingVars localVars modifiedVars
if {[regexp {\? (.*)} $item dummy var]} {
alphaHelp
eval select [search -f 1 -r 1 "^$var"]
return
}
lappend modifiedVars $item
append prmpt "New Value of " $item ": "
if ![catch {prompt $prmpt [set $item]} res] {
set $item $res
}
}
#================================================================================
# Instantiate a global variable to the path of a file (usually an app). As a
# side-effect, make the instantiation permanent.
proc addAppPath {name var} {
global $var modifiedVars
if {$name == "CodeWarrior Compiler"} {
alertnote {Please locate the compiler via menu item "Config:App Paths:CodeWarrior Compiler"}
error ""
} elseif {$name == "CodeWarrior Debugger"} {
alertnote {Please locate the debugger via menu item "Config:App Paths:CodeWarrior Debugger"}
error ""
}
set $var [getfile "Find '$name' app:"]
lappend modifiedVars $var
}
proc getFileSig {f} {
getFileInfo $f arr
return $arr(creator)
}
proc getFileType {f} {
getFileInfo $f arr
return $arr(type)
}
# Look for given app sig in active processes. If not there, try to
# launch with 'path' prompting for 'path' if necessary.
# Return the real name of the app. Don't switch.
# Slightly modified version of 'checkRunning' that looks for any of a
# list of running apps. The name of the app is returned.
#
proc checkRunning {prompt sigs path {in_front 1}} {
global $path
# See if a process w/ any of the acceptable sigs already running.
# If so, use it, whether it's the one specified by $path or not.
#
foreach proc [processes] {
# if a running app has the correct sig, ...
if {[lsearch -exact $sigs [lindex $proc 1]] >= 0} {
# ...then return its name.
return [lindex $proc 0]
}
}
# If the path variable or the file it references don't exist,
# or if its sig isn't one that we expect, then prompt the user
# to locate the app.
#
if {![info exists $path] || ![file exists [set $path]]
|| [lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
if {[catch {addAppPath $prompt $path}]} return
}
# Check that the user's choice has an acceptable sig
if {[lsearch -exact $sigs [getFileSig [set $path]]] < 0} {
unset $path
message "Inappropriate file chosen"
return {}
}
# Launch the app
if {$in_front} {
if {[catch {launch -f [set $path]}]} {
error "Problem with launching file (out of memory?)"
}
} else {
if {[catch {launch [set $path]}]} {
error "Problem with launching file (out of memory?)"
}
}
# Return the name of the chosen application
return [file tail [set $path]]
}
#===============================================================================
# Switch to 'sig', launching if necesary
proc launchForeAppl {sig} {
set name [nameFromAppl $sig]
if {[catch {switchTo "'$sig'"}]} {
launch -f $name
}
return $name
}
# Ensure that the app is at least running in the background.
proc launchBackAppl {sig} {
set name [nameFromAppl $sig]
launch $name
return $name
}
# Check to see if any of the 'sigs' is running. If so, return its name.
# Otherwise, attempt to launch the file named by 'sig'.
proc launchBackApplSigs {sigs sig {prompt "Please locate the application:"}} {
global $sig modifiedVars
foreach p [processes] {
if { [set ind [lsearch -exact $sigs [lindex $p 1]]] >= 0 } {
set s [lindex $sigs $ind]
if { ![info exists $sig] || ($s != [set $sig]) } {
set $sig $s
lappend modifiedVars $sig
}
return [nameFromAppl $s]
}
}
if {![info exists $sig] || ([set $sig] == "")} {
set $sig [getFileSig [getfile $prompt]]
lappend modifiedVars $sig
}
return [launchBackAppl [set $sig]]
}
proc getApplSig {prompt sig} {
global $sig modifiedVars
if {[catch {nameFromAppl [set $sig]}]} {
set $sig [getFileSig [getfile $prompt]]
lappend modifiedVars $sig
}
}
#================================================================================
# Excalibur is the only Mac spell-checker that I know of which will handle LaTeX as
# well as ordinary text.
proc spellcheckWindow {} {
global resumeRevert
set name [launchForeAppl XCLB]
if {[winDirty]} {
if {[askyesno "Save '[lindex [winNames] 0]'?"] == "yes"} {
save
}
}
sendOpenEvent noReply [file tail $name] [car [winNames -f]]
set resumeRevert 1
}
proc spellcheckSelection {} {
global excaliburPath
catch {checkRunning Excalibur XCLB excaliburPath} name
if {[getPos] == [selEnd]} {
beep
message "No selection"
return;
}
copy
switchTo $name
}
#================================================================================
proc alphaHelp {} {
global HOME alphaLite
if $alphaLite {
edit -r "$HOME:Help:Quick Start"
} else {
edit -r "$HOME:Help:Manual"
}
}
proc tclHelp {} {
global HOME
edit -r "$HOME:Help:Tcl Commands"
}
proc dividingLine {} {
insertText "===============================================================================\r"
}
bind 'l' <C> dividingLine
proc texDividingLine {} {
insertText "%===============================================================================\r"
}
bind 'l' <C> texDividingLine TeX
proc cDividingLine {} {
insertText "//===============================================================================\r"
}
bind 'l' <C> cDividingLine C
bind 'l' <C> cDividingLine C++
proc tclDividingLine {} {
insertText "#===============================================================================\r"
}
bind 'l' <C> tclDividingLine Tcl
#================================================================================
if {![string length [info commands oldCd]]} {
rename cd oldCd
}
proc cd args {
global HOME
if {[llength $args]} {
oldCd [string trim [eval list $args] " \{\}"]
} else {
oldCd $HOME
}
}
#############################################################################
# List the name and value of each element of the array $arrName.
# (Convenient to use as a shell command.)
#
# Note: it's slower to insert the lines one-by-one like this, but
# assembling everything in $lines before inserting can seriously crash Alpha
# if the result is too big. (Trying to list the contents of $auto_index()
# will do it.) This method seems to be more robust.
#
proc listArray {arrName} {
global $arrName
set lines {}
if {![catch {info vars $arrName}]} {
foreach nm [lsort -ignore [array names $arrName]] {
append lines [format "\r%-20s \"%s\"" $nm [set ${arrName}($nm)]]
}
insertText $lines
} else {
alertnote "\"$arrName\" doesn't exist in this context"
}
}
#================================================================================
proc selectParagraph {} {
set pos [getPos]
set start [paraStart $pos]
set finish [paraFinish $pos]
goto $start
select $start $finish
}
# wrapText == getText ; breakIntoLines ; replaceText
# Remove text from window, transform (join, del-ws), insert back into window.
proc fillTextByPar {from to} {
set text [getText $from $to]
regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
regsub -all "(\[^\r\])\r" $text "\\1 " text
regsub -all "\[ \t\]+" $text " " text
return [breakIntoLines $text]
}
proc fillRegionByPar {{start -1} {finish -1}} {
# # if {[getPos] == [selEnd]} { return}
if {($start < 0) || ($finish < 0)} {
set start [lineStart [getPos]]
set finish [selEnd] }
if {$start >= $finish} return
goto $start
set text [fillTextByPar $start $finish]
replaceText $start $finish $text "\r"
}
#
# join Lines in region -- if no optional args, use selection
#
proc joinRegion {{from -1} {to -1}} {
if {($from < 0) || ($to < 0)} { set from [getPos] ; set to [selEnd] }
if {$from >= $to} return
set text [getText $from $to]
regsub -all "\r(\[ \t\]*\r)+" $text "\r\r\r" text
regsub -all "(\[^\r\])\r" $text "\\1 " text
replaceText $from $to $text "\r"
}
# WARNING: regsub ^$ refers to string endpts (not lines)
# FUTURE: filterLines like perl:
# replaceText[apply_to_all(cmd,split [getText [getPos] [selEnd]] "\r")]
# OR: replaceInRegion: dup_\r, $=>\r ??
#
#
# Remove text from window, transform (delete dup ws), insert back into window.
#
# inputs: message, alertnote, askyesno, listpick, prompt KILLS SELECTION.
# search: bnds = search -forward -regExpr -ignoreCase -matchWords -noabort
# -l limit pat pos
#
proc regsubInRegion {from to srch repl} {
if {![string length $srch]} return
if {$from >= $to} return
set text [getText $from $to]
regsub -all "$srch" $text "$repl" text
replaceText $from $to $text
}
# while {($pos < $to) &&
# ![catch {search -s -f 1 -r 1 -i 1 -m 0 "$srch" $pos} mtch]} {
# set mbeg [lindex $mtch 0]
# set pos [lindex $mtch 1]
# replaceText $mbeg $pos $repl }
#proc backSlashSub {arg} { eval [concat return "\"$arg\""] }
proc backSlashSub {arg} {
regsub -all {\\} $arg {\\\\} arg
regsub -all {\[} $arg {\\[} arg
regsub -all {\]} $arg {\\]} arg
eval [concat return "\"$arg\""]
}
proc replaceInRegion {} {
if [catch {prompt "Search RegExpr:" ""} srch] return
if [catch {prompt "Replace String:" ""} repl] return
if {![string length $srch]} return
regsubInRegion [getPos] [selEnd] \
[backSlashSub "$srch"] [backSlashSub "$repl"]
}
#
# Apply command to each line (or paragraph) in selection ;
# if no cmd arg then prompts for it
#
proc filterLines {{cmd 0} {parunit 0}} {
if {$cmd == 0} {
if {[catch { prompt "Line-filter command: " "" } cmd]} { return } }
if {![string length $cmd]} return
set unitStart lineStart
set unitEnd nextLineStart
if {$parunit} {
set unitStart paraStart
set unitEnd paraFinish }
set pos [$unitStart [getPos]]
set finish [selEnd]
if {$pos >= $finish} return
goto $pos
createTMark "filterLend" $finish
set next [$unitEnd $pos]
while {(($next > $pos) && ($pos < $finish))} {
goto [expr $next-1]
createTMark "filterLnext" $next
setMark
goto $pos
markHilite
if {[catch [list uplevel #0 "$cmd"] retval]} {
select $pos $finish
alertnote $retval
return
}
if {$next==$finish} break
set ind [lsearch -regexp [lindex [getTMarks] 0] "filterLend.*"]
set finish [lindex [lindex [lindex [getTMarks] 0] $ind] 2]
gotoTMark "filterLnext"
set pos [$unitStart [getPos]]
set next [$unitEnd $pos]
}
removeTMark "filterLend"
removeTMark "filterLnext"
}
proc filterParagraphs {{cmd 0}} { filterLines $cmd 1 }
# WARNING: deselecting sets the mark to selEnd
proc sortParagraphs {{from -1} {to -1}} {
if {($from < 0) || ($to < 0)} { set from [getPos] ; set to [selEnd] }
if {$from >= $to} return
joinRegion {$from $to}
select [getPos] [nextLineStart [getMark]]
sortLines
select [getPos] [getPos]
regsubInRegion [getPos] [getMark] "\r" "\r\r"
wrapRegion
}
#
# Sample
#
proc filterRegion {{from -1} {to -1} {cmd 0} {newwin 0}} {
if {$cmd == 0} {
if {[catch { prompt "Eval command: " "" } cmd]} { return }
}
if {![string length $cmd]} return
if {($from < 0) || ($to < 0)} { set from [getPos] ; set to [selEnd] }
if {$from >= $to} return
set pos [getPos]
set text [getText $from $to]
set text [$cmd $text]
replaceText $from $to $text "\r"
goto $pos
}
#
set lastEvaled ""
proc evaluate {} {
global lastEvaled
if {[string length $lastEvaled]} {
set p "M-x ($lastEvaled): "
} else {
set p "M-x: "
}
if {[catch {statusPrompt $p} text]} {return}
if {![string length $text]} {set text $lastEvaled}
$text
set lastEvaled $text
}
# First, define macros to bypass the electric braces.
proc ordLeftBrace {} {
insertText " \{"
}
bind {'['} <cs> ordLeftBrace
proc ordRightBrace {} {
insertText "\}"
blink [matchIt "\}" [expr [getPos]-1]]
}
bind {']'} <cs> ordRightBrace
proc quoteWord {} {
backwardWord
insertText "'"
forwardWord
insertText "'"
}
bind ''' <z> quoteWord
#================================================================================
proc tomac {fname} {
set fd [open $fname "r"]
set text [read $fd]
close $fd
set fd [open $fname "w"]
regsub "\n" $text "\r" text
puts -nonewline $fd $text
close $fd
}
proc tounix {fname} {
set fd [open $fname "r"]
set text [read $fd]
close $fd
set fd [open $fname "w"]
regsub "\r" $text "\n" text
puts -nonewline $fd $text
close $fd
}
proc cat args {
set files ""
foreach a $args {
foreach f [glob $a] {
lappend files $f
}
}
foreach f $files {
append text "==============<$f>==============\r"
set fd [open $f "r"]
append text "[read $fd]\r\r"
close $fd
}
return $text
}
proc catto args {
set len [llength $args]
set to [lindex $args [expr $len -1]]
set args [lrange $args 0 [expr $len -2]]
set files ""
foreach a $args {
foreach f [glob $a] {
lappend files $f
}
}
foreach f $files {
append text "==============<$f>==============\r"
set fd [open $f "r"]
append text "[read $fd]\r\r"
close $fd
}
set dfile $to
if {[file exists $dfile]} {
set fid [open $dfile "a"]
} else {
set fid [open $dfile "w"]
}
puts $fid $text
close $fid
}
##############################################################################
# To be used in the windows created by "matchingLines" or by batch searches.
#
# With the cursor positioned in a line corrsponding to a match,
# go back and select the line in the original file that
# generated this match. (Like emacs 'Occur' functionality)
#
proc gotoMatch {} {
if {[string match "*MAILBOX*" [lindex [winNames] 0]]} {
mailGotoMatch
return
}
global tileHeight tileWidth tileTop tileLeft tileHeight errorHeight errorDisp tileMargin
set errorDisp [expr (2 * ($tileHeight - $tileMargin)) / 3]
set text [getText [lineStart [getPos]] [expr [nextLineStart [getPos]] - 1]]
set ind1 [string first "∞" $text]
set ind2 [string last "∞" $text]
if {$ind1 == $ind2} {
set fname [string trim [string range $text $ind1 end] {∞}]
set msg ""
} else {
set fname [string trim [string range $text $ind1 $ind2] {∞}]
set msg [string trim [string range $text $ind2 end] {∞}]
}
set top $tileTop
set geo [getGeometry]
if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 3] != $errorHeight) } {
moveWin $tileLeft $top
sizeWin $tileWidth $errorHeight
}
set mar $tileMargin
incr top [expr $errorHeight + $mar]
if {[expr {[lsearch [winNames -f] "*$fname"] >= 0}]} {
if {[string match ":*" $fname]} {
set fname [file tail $fname]
}
bringToFront $fname
set geo [getGeometry]
if {([lindex $geo 0] != $tileLeft) || ([lindex $geo 1] != $top) || ([lindex $geo 2] != $tileWidth) || ([lindex $geo 3] != $errorDisp) } {
sizeWin $tileWidth $errorDisp
moveWin $tileLeft $top
}
} elseif {[file exists $fname]} {
edit -g $tileLeft $top $tileWidth $errorDisp $fname
} else {
if {![string match "*Link*" [getText 0 [nextLineStart 0]]]} {
alertnote "File \" $fname \" not found."
}
return
}
if {[regexp {Line ([0-9]+):} $text dummy line]} {
set pos [rowColToPos $line 0]
select $pos [nextLineStart $pos]
}
message $msg
}
bind 'c' <Cz> gotoMatch
#================================================================================
proc prevIntro {} {
set res [search -s -f 0 -r 0 {== } [getPos]]
display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
}
proc nextIntro {} {
set res [search -s -f 1 -r 0 {== } [getPos]]
set res [lindex $res 1]
set res [search -s -f 1 -r 0 {== } $res]
display [lineStart [expr [lineStart [lindex $res 0]] - 1]]
}
#================================================================================
proc searchStart {} {
global search_start
select [getPos]
setMark
if {[catch {goto $search_start}]} {message "No previous search"}
}
#================================================================================
proc listBindings {} {
new -n {* Key Bindings *}
insertText [bindingList]
goto 0
setWinInfo dirty 0
setWinInfo read-only 1
}
proc listFunctions {} {
global winModes
new -n {* Functions *}
insertText "===\r\tCommand-double-click on a function to see its definition\r===\r\r" [join [lsort -ignore [info commands]] "\r"] "\r"
goto 0
setWinInfo dirty 0
changeMode [set winModes([lindex [winNames] 0]) Tcl]
}
#================================================================================
proc printArray {arr} {
global $arr
foreach n [array names $arr] {
append text "$n '[set ${arr}($n)]'\r"
}
return [string trim $text "\r"]
}
#================================================================================
#================================================================================
proc sPrompt {msg def} {
global useStatusBar
if {!$useStatusBar} {return [prompt $msg $def]}
if {[catch {statusPrompt "$msg ($def): "} ans]} {
error "cancel"
}
if {![string length $ans]} {return $def}
return $ans
}
proc choicesProc {curr c} {
global choiceList
if {$c != "\t"} {return $c}
set matches {}
foreach w $choiceList {
if {[string match "$curr*" $w]} {
lappend matches $w
}
}
if {![llength $matches]} {
beep
} else {
return [string range [largestPrefix $matches] [string length $curr] end]
}
return ""
}
proc sPromptChoices {msg def choiceListIn} {
global useStatusBar choiceList
set choiceList $choiceListIn
if {[catch {statusPrompt -f "$msg ($def): " choicesProc} ans]} {
error "cancel"
}
if {![string length $ans]} {return $def}
return $ans
}
#================================================================================
proc quoteChar {} {
message "Literal keystroke to be inserted:"
insertText [getChar]
}
#===============================================================================
proc saveACopyAs {} {
if {[file exists [set nm [car [winNames -f]]]]} {
set nm2 [putfile "Save a copy as:" [file tail $nm]]
cp $nm $nm2
}
}
#===============================================================================
proc removeDups {l} {
foreach f $l {
set silly($f) 1
}
if {[info exists silly]} {
return [array names silly]
}
}
#===============================================================================
proc printLeftHeader {pg} {
global printHeader printHeaderTime printHeaderFullPath
if {!$printHeader} return ""
if {$printHeaderFullPath} {
set text [car [winNames -f]]
} else {
set text [lindex [winNames] 0]
}
if {$printHeaderTime} {
append text " [join [mtime [now] short]]"
}
}
proc printRightHeader {pg} {
return "Page $pg"
}
#===============================================================================
proc toggleNumLock {} {
global numLock modifiedVars
set numLock [expr -1 * ($numLock - 1)]
lappend modifiedVars numLock
}
#===============================================================================
proc register {} {
global HOME
# edit -r "$HOME:Help:Registering"
launch -f "$HOME:Register"
}
#===============================================================================
# Useful for -command flag of 'lsort'.
proc sortByTail {one two} {
string compare [file tail $one] [file tail $two]
}
#===============================================================================
proc cmdDoubleClick {{from -1} {to -1} {shift 0} {option 0} {control 0}} {
global mode alphaLite
if {!$alphaLite && [string length [set whe [expandURL]]]} {
sendUrl [getSelect]
} else {
if {$from < 0} {
set from [getPos]
set to [selEnd]
if {$from == $to} {
hiliteWord
set from [getPos]
set to [selEnd]
}
}
if {[string length [info commands ${mode}DblClick]]} {
if {[llength [info args ${mode}DblClick]] == 2} {
${mode}DblClick $from $to
} else {
${mode}DblClick $from $to $shift $option $control
}
} else {
message "No docs"
}
}
}
#===============================================================================
proc editMark {fname mname args} {
if {[set pos [lsearch [winNames -f] "*$fname*"]] >= 0} {
bringToFront [lindex [winNames -f] $pos]
} else {
if {[lsearch $args {-r}] >= 0} {
edit -r "$fname"
} else {
edit "$fname"
}
}
if {[lsearch [getNamedMarks -n] $mname] < 0} {
global mode
${mode}MarkFile
}
gotoMark $mname
}
proc winDirty {} {
getWinInfo arr
return $arr(dirty)
}
#===============================================================================
proc lreverse {l} {
if {[llength $l] > 1} {
set first [lindex $l 0]
set l [lreverse [lrange $l 1 end]]
lappend l $first
}
return $l
}
#===============================================================================
set {patternLibrary(Pascal to C Comments)} { {\{([^\}]*)\}} {/* \1 */} }
set {patternLibrary(C++ to C Comments)} { {//(.*)} {/* \1 */} }
set {patternLibrary(Space Runs to Tabs)} { { +} {\t} }
proc getPatternLibrary {} {
global patternLibrary
foreach nm [array names patternLibrary] {
lappend nms [concat [list $nm] $patternLibrary($nm)]
}
return $nms
}
proc rememberPatternHook {search replace} {
global patternLibrary
if {[catch {set name [prompt "New pattern's name?" ""]}]} {
return ""
}
addArrDef patternLibrary $name [list $search $replace]
set patternLibrary($name) [list $search $replace]
return $name
}
proc deletePatternHook {} {
global patternLibrary
set temp [list prompt "Delete which pattern?" [lindex [array names patternLibrary] 0] "Pats:"]
set name [eval [concat $temp [array names patternLibrary]]]
removeArrDef patternLibrary $name
unset patternLibrary($name)
}
#===============================================================================
# Support for Peter Gontier's 'ClickWarrior' (Doesn't work for 68k).
#===============================================================================
eventHandler ALFA CWOF clickHandler
proc clickHandler {msg} {
global HOME ALPHA CODEWarrior CWCLASS
switchTo $ALPHA
checkCw
if {[regexp {“(.*)”.*«.*».*«(.*)».*«(.*)»} $msg dummy fname find sind]} {
set res [AEBuild -t 500000 -r $CODEWarrior $CWCLASS GFil "----" "long(«0000$find»)" Segm "long($sind)"]
if {[regexp {FTxt} $res]} {
regexp {«(.*)»} $res dummy spec
set f [specToPathName $spec]
edit $f
}
}
}
#===============================================================================
proc quickFind {} {isearch}
proc reverseQuickFind {} {rsearch}
proc pushPosition {} {pushMark}
proc popPosition {} {popMark}
#===============================================================================
proc literalChar {} {
return [expr {[lookAt [expr [getPos] - 1]] == "\\"}]
}
proc isSelection {} {
return [string length [getSelect]]
}
proc findPatJustBefore { findpat pat {pos ""} {matchw ""} } {
if { $pos == "" } {set pos [getPos] }
if { $matchw != "" } { upvar $matchw word }
if { ![catch {search -s -f 0 -r 1 "$findpat" $pos} res] } {
if { [regexp "$pat" [getText [lindex $res 0] $pos] dum word] } {
return [lindex $res 0]
}
}
return
}
#===============================================================================
proc mkdir {dir} {
oldMkdir [list $dir]
}
proc rmdir {dir} {
oldRmdir [list $dir]
}
#===============================================================================
proc textToAlpha {{dir ""}} {
set num 0
if {![string length $dir]} {
set dir [get_directory -p "Creators to 'ALFA':"]
}
if {![catch {glob "$dir:*"} files]} {
foreach f $files {
if {[file isfile $f] && ([getFileType $f] == "TEXT") && ([getFileSig $f] != "ALFA")} {
message $f
setFileInfo $f creator ALFA
incr num
} elseif {[file isdir $f]} {
incr num [textToAlpha $f]
}
}
}
message "Converted $num files"
return $num
}
#===============================================================================
proc briefThing {} {
global lastBrief
getWinInfo arr
set curr $arr(currline)
set where [posToRowCol [getPos]]
set row [car $where]
set col [cadr $where]
if {$col} {
set lastBrief [getPos]
goto [lineStart [getPos]]
} elseif {$curr != $row} {
goto [rowColToPos $curr 0]
} elseif {[getPos]} {
goto 0
} else {
goto $lastBrief
}
}
########################################
# #
# A few random lisp'ish functions. #
# #
########################################
proc car {l} {lindex $l 0}
proc cadr {l} {lindex $l 1}
proc caddr {l} {lindex $l 2}
proc cadddr {l} {lindex $l 3}
proc caddddr {l} {lindex $l 4}
proc cdr {l} {lrange $l 1 end}
proc cddr {l} {lrange $l 2 end}
proc cons {e l} {concat [list $e] $l}
proc mapcar args {return [eval map $args]}
proc map {func l} {
set out {}
foreach el $l {
lappend out [eval $func [list $el]]
}
return $out
}
#===============================================================================
proc deconstruct {} {
global HOME
set files {}
if {![catch {glob "$HOME:Tcl:Modes:*Mode.tcl"} modes]} {
set files $modes
}
if {![catch {glob "$HOME:Tcl:Menus:*Menu.tcl"} menus]} {
set files [concat $files $menus]
}
foreach f $files {
regexp {.*:(.*)M.*.tcl} $f dummy it
set theFiles($it) $f
lappend tails $it
}
set res [listpick -p "Permanently remove which modes and menus?" -l [lsort -ignore $tails]]
if {[llength $res] && ([askyesno "Are you absolutely sure?"] == "yes")} {
foreach tag $res {
set name $theFiles($tag)
regexp {(.*)M.*.tcl} $name dummy prefix
foreach f [glob "${prefix}*.tcl"] {
lappend rfiles $f
}
set tag [file tail $tag]
if {$tag == "perl"} {
catch {rm $HOME:Help:*Perl*}
} elseif {$tag == "latex"} {
catch {rm $HOME:Help:LaTeX*}
} elseif {$tag == "bibtex"} {
catch {rm $HOME:Help:Bib*}
} elseif {$tag == "html"} {
catch {rm $HOME:Help:HTML*}
}
}
foreach f $rfiles {
catch {rm $f}
}
foreach dir [list "$HOME:Tools" "$HOME:Tcl:ElectricAlias" "$HOME:Tcl:UserCode" "$HOME:Help"] {
if {[file exists $dir] && ([askyesno "Remove '$dir'?"] == "yes")} {
if {[catch {recursiveRm $dir}]} {
alertnote "Problem removing '$dir'."
}
}
}
rebuildTclIndices
alertnote "You must now restart Alpha..."
quit
}
}
proc recursiveRm dir {
if {![catch {glob $dir:*} files]} {
foreach f $files {
if {[file isdir $f]} {
recursiveRm $f
} else {
rm $f
}
}
}
rmdir $dir
}
###########################################################################
# better-cp-mv.tcl -- modification of your routines, by Mark Nagata
# for Alpha 5.72, 1/04/94
###########################################################################
proc cp args {
if {[set len [llength $args]] < 2} {
error "usage: cp <file1> <file2>\r cp <file1> .... <dir>"
}
set len [expr $len-1]
set dir [lindex $args $len]
if {![regexp {:} $dir] && $dir != ""} {
set dir ":$dir"
}
if {[regexp {:$} $dir]} {
set dir [string trimright $dir {:}]
}
set args [lreplace $args $len $len]
set files {}
foreach arg $args {
append files " " [glob $arg]
}
set report ""
if {[llength $files] == 1} {
set f [lindex $files 0]
if {[file exists $dir]} {
set targ $dir:[file tail $f]
append report $f\ ->\ $targ \r
copyFile $f $targ
} else {
append report $f\ ->\ $dir \r
copyFile $f $dir
}
} else {
foreach f $files {
message [file tail $f]
set targ $dir:[file tail $f]
if {[catch {copyFile $f $targ} that]} {
append report "Error copying '$f': $that\r"
} else {
append report $f\ ->\ $targ \r
}
}
}
echo [string trimright $report]
}
proc mv args {
if {[set len [llength $args]] < 2} {
error "usage: mv <file1> <file2>\r mv <file1> .... <dir>"
}
set len [expr $len-1]
if {![regexp {.*[^:]} [lindex $args $len] dir]} {
set dir [string range [lindex $args $len] 1 end]
}
if {![regexp {:} $dir] && $dir != ""} {
set dir [concat :$dir]}
set args [lreplace $args $len $len]
set files {}
foreach arg $args {
append files " " [glob $arg]
}
set report ""
if {[llength $files] == 1} {
set f [lindex $files 0]
if {[file exists $dir]} {
set targ $dir:[file tail $f]
append report $f\ >->\ $targ \r
moveFile $f $targ
} else {
append report $f\ >->\ $dir \r
moveFile $f $dir
}
} else {
foreach f $files {
message [file tail $f]
set targ $dir:[file tail $f]
if {[catch {moveFile $f $targ} that]} {
append report "Error moving '$f': $that\r"
} else {
append report $f\ >->\ $targ \r
}
}
}
echo [string trimright $report]
}
proc rm args {
set files {}
foreach arg $args {
append files " " [glob $arg]
}
foreach f $files {
message [file tail $f]
removeFile $f
}
}